VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "clsMCTSNode"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)

'the move that got us to this node
Private m_lpMove As Long
Private m_lpParentNode As Long

Private m_objChildNodes() As clsMCTSNode, m_nChildCount As Long, m_nChildMax As Long

Private m_bUntriedMoves() As Byte, m_nSize As Long, m_nUntriedMoveCount As Long

Private m_nWins As Long, m_nVisits As Long

Private m_objState As IGameState

Friend Property Get ChildNode(ByVal nIndex As Long) As clsMCTSNode
Set ChildNode = m_objChildNodes(nIndex)
End Property

'FIXME: process the case that given move is not listed in available moves,
'but gets the same result with some available move
Friend Function GetChildNodeFromMoves(ByVal lpData As Long, ByVal nSize As Long) As clsMCTSNode
Dim i As Long, j As Long
Dim b1() As Byte, b2() As Byte
Dim b As Boolean
'///
If lpData = 0 Or nSize <= 0 Then Exit Function
ReDim b1(nSize - 1)
ReDim b2(nSize - 1)
CopyMemory b1(0), ByVal lpData, nSize
'///
For i = 0 To m_nChildCount - 1
 If m_objChildNodes(i).MovePointer <> 0 And m_objChildNodes(i).MoveSize = nSize Then
  CopyMemory b2(0), ByVal m_objChildNodes(i).MovePointer, nSize
  b = True
  For j = 0 To nSize - 1
   If b1(j) <> b2(j) Then
    b = False
    Exit For
   End If
  Next j
  If b Then
   Set GetChildNodeFromMoves = m_objChildNodes(i)
   Exit Function
  End If
 End If
Next i
End Function

Friend Property Get MovePointer() As Long
MovePointer = m_lpMove
End Property

Friend Property Get MoveSize() As Long
If m_lpMove <> 0 Then MoveSize = m_nSize
End Property

Friend Property Get ParentNode() As clsMCTSNode
Dim obj As clsMCTSNode
If m_lpParentNode <> 0 Then
 CopyMemory ByVal VarPtr(obj), m_lpParentNode, 4&
 Set ParentNode = obj
 CopyMemory ByVal VarPtr(obj), 0&, 4&
End If
End Property

Friend Property Get GameState() As IGameState
Set GameState = m_objState
End Property

Friend Property Get VisitTime() As Long
VisitTime = m_nVisits
End Property

Friend Property Get WinProbability() As Double
If m_nVisits > 0 Then WinProbability = m_nWins / m_nVisits
End Property

Friend Sub UnlinkParent()
m_lpMove = 0
m_lpParentNode = 0
End Sub

'return value: objState.GetResult(objState.PlayerJustMoved) (3=not finished)
Friend Function Create(ByVal lpParent As Long, ByVal lpMove As Long, ByVal nSize As Long, ByVal objState As IGameState, ByVal bRespectRandomFactor As Boolean) As Long
Dim f As Long
'///
m_lpMove = lpMove
m_lpParentNode = lpParent
m_nSize = nSize
'///bug fixed: we should check if one player wins
f = objState.GetResult(objState.PlayerJustMoved)
If f = 3 Then m_nUntriedMoveCount = objState.GetMoves(m_bUntriedMoves, m_nSize, bRespectRandomFactor) _
Else m_nUntriedMoveCount = 0
Create = f
'///
Set m_objState = objState
End Function

Friend Function UCTSelectChild() As clsMCTSNode
Dim i As Long, j As Long
Dim c As Double
Dim f As Double, m As Double
'///
If m_nChildCount <= 0 Then Exit Function
'///
j = -1
m = -1E+300
c = 2 * Log(m_nVisits)
For i = 0 To m_nChildCount - 1
 f = m_objChildNodes(i).UpperConfidenceBounds(c)
 If f > m Then
  j = i
  m = f
 End If
Next i
Debug.Assert j >= 0
Set UCTSelectChild = m_objChildNodes(j)
End Function

Friend Function MostVisitedChild() As clsMCTSNode
Dim i As Long, j As Long
Dim f As Long, m As Long
j = -1
m = -1
For i = 0 To m_nChildCount - 1
 f = m_objChildNodes(i).VisitTime
 If f > m Then
  j = i
  m = f
 End If
Next i
If j >= 0 Then Set MostVisitedChild = m_objChildNodes(j)
End Function

Friend Sub Test(ByRef s() As String)
Dim i As Long, j As Long
Dim b() As Byte
ReDim b(m_nSize)
ReDim s(m_nChildCount)
'///
For i = 0 To m_nChildCount - 1
 If m_nSize > 0 Then
  CopyMemory b(0), ByVal m_objChildNodes(i).MovePointer, m_nSize
  For j = 0 To m_nSize - 1
   s(i) = s(i) + Right("0" + Hex(b(j)), 2)
  Next j
 End If
 s(i) = s(i) + vbTab + CStr(m_objChildNodes(i).VisitTime) + vbTab + Format(m_objChildNodes(i).WinProbability, "0.000%")
Next i
'///
End Sub

Friend Property Get UntriedMoveCount() As Long
UntriedMoveCount = m_nUntriedMoveCount
End Property

Friend Sub Update(ByVal nResult As Long)
Debug.Assert nResult >= 0 And nResult <= 1
m_nWins = m_nWins + nResult
m_nVisits = m_nVisits + 1
End Sub

''obj should be in m_objChildNodes, or unexpected error may occur
'Friend Sub KillOtherNodes(ByVal obj As clsMCTSNode)
'ReDim m_objChildNodes(0)
'm_nChildCount = 1
'm_nChildMax = 1
'm_nUntriedMoveCount = 0
'Set m_objChildNodes(0) = obj
'End Sub
'
'Friend Sub KillParentOtherNodes()
'If m_lpParentNode <> 0 Then ParentNode.KillOtherNodes Me
'End Sub

'internal function. will do optimizations
Friend Function AddRandomChild(ByVal bReversed As Boolean) As clsMCTSNode
Dim idx As Long
Dim i As Long, j As Long, k As Long, b As Byte
Dim obj As clsMCTSNode
Dim objState As IGameState
'///random select
If m_nUntriedMoveCount <= 0 Then Exit Function
idx = Int(m_nUntriedMoveCount * Rnd)
j = idx * m_nSize
k = (m_nUntriedMoveCount - 1) * m_nSize
If j < k Then
 '///swap them
 For i = 0 To m_nSize - 1
  b = m_bUntriedMoves(j + i)
  m_bUntriedMoves(j + i) = m_bUntriedMoves(k + i)
  m_bUntriedMoves(k + i) = b
 Next i
End If
'///expand
Set obj = New clsMCTSNode
Set objState = m_objState.Clone
If Not objState.DoMove(VarPtr(m_bUntriedMoves(k)), m_nSize) Then
 Debug.Assert False
 Exit Function
End If
i = obj.Create(ObjPtr(Me), VarPtr(m_bUntriedMoves(k)), m_nSize, objState, False)
If bReversed And i <= 1 Then i = 1 - i 'ad-hoc test
'FIXME: these codes are not compatible with random factor
'FIXME: and causes weird AI bugs in Pentago (in some special cases)
'///kill other nodes if win (?)
If i = 1 Then
 m_nUntriedMoveCount = 0
 m_nChildCount = 1
 m_nChildMax = 1
 ReDim m_objChildNodes(0)
 Set m_objChildNodes(0) = obj
Else
 '///
 m_nUntriedMoveCount = m_nUntriedMoveCount - 1
 '///save if we don't lose or there is the last node. (??)
 If i <> 0 Or (m_nUntriedMoveCount <= 0 And m_nChildCount <= 0) Then
  m_nChildCount = m_nChildCount + 1
  If m_nChildCount > m_nChildMax Then
   m_nChildMax = m_nChildMax + 256&
   ReDim Preserve m_objChildNodes(m_nChildMax - 1)
  End If
  Set m_objChildNodes(m_nChildCount - 1) = obj
 End If
End If
'///over
Set AddRandomChild = obj
End Function

Friend Function FilterChildByRandomFactor(ByVal objState As IGameState) As Boolean
Dim i As Long, j As Long
'///kill nodes with wrong random factor
For i = 0 To m_nChildCount - 1
 If objState.FilterByRandomFactor(m_objChildNodes(i).MovePointer, m_objChildNodes(i).MoveSize) Then
  If j > 0 Then Set m_objChildNodes(i - j) = m_objChildNodes(i)
 Else
  j = j + 1
 End If
Next i
m_nChildCount = m_nChildCount - j
For i = m_nChildCount To m_nChildMax - 1
 Set m_objChildNodes(i) = Nothing
Next i
'///kill untried moves with wrong random factor
j = 0
For i = 0 To m_nUntriedMoveCount - 1
 If objState.FilterByRandomFactor(VarPtr(m_bUntriedMoves(i * m_nSize)), m_nSize) Then
  If j > 0 Then CopyMemory m_bUntriedMoves((i - j) * m_nSize), m_bUntriedMoves(i * m_nSize), m_nSize
 Else
  j = j + 1
 End If
Next i
m_nUntriedMoveCount = m_nUntriedMoveCount - j
'///debug test (??)
FilterChildByRandomFactor = m_nChildCount + m_nUntriedMoveCount > 0
End Function

Friend Function UpperConfidenceBounds(ByVal nLogParentVisitsWithCoefficient As Double) As Double
UpperConfidenceBounds = m_nWins / m_nVisits + Sqr(nLogParentVisitsWithCoefficient / m_nVisits)
End Function

Friend Function Run(ByVal nMax As Long, ByVal bReversed As Boolean) As Boolean
Dim i As Long
Dim objNode As clsMCTSNode
Dim objState As IGameState
Dim bData() As Byte, nSize As Long
Dim nPlayerJustMoved As Long
Dim f As Long
'///
For i = 1 To nMax
 '///Select
 Set objNode = Me
 Do While objNode.UntriedMoveCount = 0 _
 And objNode.ChildCount > 0 'node is fully expanded and non-terminal
  Set objNode = objNode.UCTSelectChild
  Debug.Assert Not objNode Is Nothing
 Loop
 '///Expand
 If objNode.UntriedMoveCount > 0 Then 'if we can expand (i.e. state/node is non-terminal)
  Set objNode = objNode.AddRandomChild(bReversed) 'add child and descend tree
 End If
 '///Rollout
 'this can often be made orders of magnitude quicker using a state.GetRandomMove() function
 Set objState = objNode.GameState.Clone
 nPlayerJustMoved = objState.PlayerJustMoved
 Do
  'get game result
  f = objState.GetResult(nPlayerJustMoved)
  If f >= 0 And f <= 2 Then
   'if draw then changed it to random value
   If f = 2 Then f = Int(2 * Rnd)
   Exit Do
  End If
  'get random moves
  If Not objState.GetRandomMoves(bData, nSize, bReversed) Then
   'something goes wrong
   Debug.Assert False
   Exit Function
  End If
  If Not objState.DoMove(VarPtr(bData(0)), nSize) Then
   'something goes wrong
   Debug.Assert False
   Exit Function
  End If
 Loop
 '///Backpropagate
 If bReversed Then f = 1 - f 'ad-hoc test
 Do Until objNode Is Nothing
  objNode.Update f
  f = 1 - f
  Set objNode = objNode.ParentNode
 Loop
Next i
'///over
Run = True
End Function

Friend Property Get ChildCount() As Long
ChildCount = m_nChildCount
End Property
